Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/ISSUE08/DATADICT/DBUTILS.PAS

Pascal/Delphi Source File | 1996-02-15 | 35.8 KB | 961 lines

unit Dbutils;

interface
uses SysUtils, Classes, Forms, Controls, Dialogs, Grids,
     StdCtrls, DB, DBctrls, DBTables, inifiles;
const
    FieldTypeStr : array[ftunknown..ftgraphic] of string[8] =
      ('Unknown', 'String', 'Smallint', 'Integer', 'Word',
       'Boolean', 'Float', 'Currency', 'BCD', 'Date', 'Time',
       'DateTime', 'Bytes', 'VarBytes', 'Blob', 'Memo', 'Graphic');
    FieldTypeLtr : array[ftunknown..ftgraphic] of string[1] =
      ('U', 'S', 'I', 'N', 'W',
       'L', 'F', 'C', 'B', 'D', 'T',
       'A', 'Y', 'V', 'O', 'M', 'G');

type
    ddfOffsets = (ddfTABLE_NAME, ddfFIELD_NAME, ddfTAG, ddfSCR_PROMPT, ddfSCR_FMT,
                  ddfGRD_PROMPT, ddfGRD_WIDTH, ddfFIELD_TYPE, ddfFIELD_LEN, ddfFIELD_DEC,
                  ddfFIELD_IDX, ddfIDX_EXPRES, ddfTAB_ORDER, ddfREQUIRED, ddfDEFAULT,
                  ddfEDITMASK, ddfMINVAL, ddfMAXVAL, ddfVALLIST, ddfDefine, ddfValidValue,
                  ddfNotes, ddfHINT, ddfHELPID, ddfHelp, ddfTable_type, ddfHASLINK,
                  ddfSRCLINKTBL, ddfSRCLINKFLD, ddfIS_CALC, ddfFORMULA);
const
    DictTableFieldNames : array[ddfTable_Name..ddfFormula] of string[12] =
       ('TABLE_NAME', 'FIELD_NAME', 'TAG', 'SCR_PROMPT', 'SCR_FMT', 'GRD_PROMPT', 'GRD_WIDTH',
        'FIELD_TYPE','FIELD_LEN','FIELD_DEC','FIELD_IDX','IDX_EXPRES','TAB_ORDER','REQUIRED',
        'DEFAULT','EDITMASK','MINVAL','MAXVAL','VALLIST','DEFINE', 'VALIDVALUE', 'NOTES',
        'HINT','HELPID','HELP', 'TABLE_TYPE', 'HASLINK','SRCLINKTBL',
        'SRCLINKFLD', 'IS_CALC', 'FORMULA' );

type
  tdictctrl = class(TComponent)
  private
    FiniFile : TiniFile;
    FCtrlDictName : Tfilename;
    FDBSGGood : boolean;
    FCurrentTableName,
    FCurrentFieldName : string;
    fCurrentField : integer;
    FtempdbMemo : TDBmemo;
    procedure ReadIniFile;
    function getDictPath : tfilename;
    procedure setDictPath( tmpstr : tfilename);
    function getDictTable : tfilename;
    procedure setDictTable (tmpstr : tfilename);
    function getCurrentTableName : string;
    function getCurrentFieldName : string;
    function GetCurrentHint : string;
    function GetRequired : boolean;
    function GetMinVal : longint;
    function GetMaxVal : longint;
  protected
    function setFieldDefs(var tableToDefine : Ttable; const FieldNum : integer): boolean;
    function SetUpCommon(var TableToDefine : ttable; const FieldNum : integer): boolean;
    function SetUpString(var TableToDefine : ttable; const FieldNum : integer): boolean;
    function SetUpBoolean(var TableToDefine : ttable; const FieldNum : integer): boolean;
    function SetUpDate(var TableToDefine : ttable; const FieldNum : integer): boolean;
    function SetUpDateTime(var TableToDefine : ttable; const FieldNum : integer): boolean;
    function SetUpTime(var TableToDefine : ttable; const FieldNum : integer): boolean;
    function SetUpBytes(var TableToDefine : ttable; const FieldNum : integer): boolean;
    function SetUpVarBytes(var TableToDefine : ttable; const FieldNum : integer): boolean;
    function SetUpBlob(var TableToDefine : ttable; const FieldNum : integer): boolean;
    function SetUpMemo(var TableToDefine : ttable; const FieldNum : integer): boolean;
    function SetUpGraphic(var TableToDefine : ttable; const FieldNum : integer): boolean;
    function doNumbers(const whichtype : TfieldType; var TableToDefine : ttable; const FieldNum : integer): boolean;
    procedure FillTableList;
  public
    FDBSG : Tstringgrid;
    FDBTableList : TStringList;
    constructor create(aOwner : Tcomponent);
    destructor putaway;
    Procedure OpenDictionary(const fullTableName : string;
                               var whichdb : tdatabase; var whichtable : ttable;
                               var whichQuery : tquery; var whichsource : tDataSource);
    Procedure FillStringGrid(var WhichTable : Ttable);
    function GetFieldAsString(const fieldname: string; var whichtable : ttable): string;
    function SetUpTable(var TableToSetUp : ttable): boolean;
    function SetCurrentFieldTo(const tablename, fieldname : string): boolean;
    function BuildEmptyTable(var TableToBuild : ttable; const TableName : string): boolean;
  published
    property DictPath: Tfilename read getDictPath write SetDictPath;
    property DictTable: Tfilename read getDictTable write SetDictTable;
    property DBSGExists : boolean read FDBSGGood;
    property CurrentTableName : string read GetCurrentTableName;
    property CurrentFieldName : string read GetCurrentFieldName;
    property Hint : string read getCurrentHint;
    property Required : boolean read getRequired;
    property MinValue : longint read getMinVal;
    property MaxValue : longint read getMaxVal;
  end;

procedure Register;

var
  DictCtrl : TDictCtrl;

    DBSGExists : boolean;

function openDB(var whichdb : tdatabase; var whichtable : ttable;
                var whichQuery : tquery; var whichsource : tDataSource;
                const pathname, tablename : string): boolean;

function FieldSummary(which : tquery): string;


implementation
uses utils, mystrng; {dbierrs, dbiprocs,dbitypes;}
type
  buffer = array[0..32000] of byte;

(*
const
   {indexes into DBSG columns}
      tablename = 0;  {string 20}
      tabletype = 1;  {string 20}
      fieldname = 2;  {string[20];}
      tag       = 3;  {string 20  tfield.tag}
      scrprompt = 4;  {string[40]; {tfield.DisplayName}
      scrformat = 5;  {string[80]; {tfield.DisplayText -- an editmask}
      grdprompt = 6;  {string[10];}
      grdwidth  = 7;  {smallint    {tfield.DisplayWidth}
      fldtype   = 8;  {string[1];  {FieldTypeLtr}
      fldlen    = 9;  {smallint    {tfield.size}
      flddec    = 10; {smallint}
      fldidx    = 11; {boolean;}
      idxexp    = 12; {string;}
      tab_order = 13; {integer;}
      isrequired  = 14; {boolean;    {tfield.required}
      defaultis   = 15; {string[80];}
      editmaskis  = 16; {string[80]; {tfield.editMask}
      minval    = 17; {ftfloat  tfield.minvalue}
      maxval    = 18; {ftfloat  tfield.maxvalue}
      vallist   = 19; {ftmemo   list of valid strings}
      { define      documentation only
        validvalue  documentation only
        notes       documentation only}
      hintTxt   = 20;  {string 120}
      helpid    = 21;  {longint;}
      {help, memo only used if helpid not null or 0}
      haslink   = 22;  {boolean;}
      srclinktbl = 23; {string[20];}
      srclinkfld = 24; {string[20];}
      iscalc     = 25; {boolean;}
      formula    = 26; {memo only used if iscalc true}
*)
type
   TDictCtrlStringGrid = TStringGrid;

function FieldSummary(which : tquery): string;
var tmpstr : string;
begin
 tmpstr := Which.findfield('TABLE_NAME').text+' : ';
 tmpstr := tmpstr +Which.findfield('FIELD_NAME').text+' : ';
 case Which.findfield('FIELD_TYPE').text[1] of
       'S'  : tmpstr := tmpstr + ' String  '  ;
       'I'  : tmpstr := tmpstr + ' Smallint'  ;
       'N'  : tmpstr := tmpstr + ' Integer '  ;
       'W'  : tmpstr := tmpstr + ' Word    '  ;
       'L'  : tmpstr := tmpstr + ' Boolean '  ;
       'F'  : tmpstr := tmpstr + ' Float   '  ;
       'C'  : tmpstr := tmpstr + ' Currency'  ;
       'B'  : tmpstr := tmpstr + ' BCD     '  ;
       'D'  : tmpstr := tmpstr + ' Date    '  ;
       'T'  : tmpstr := tmpstr + ' Time    '  ;
       'A'  : tmpstr := tmpstr + ' DateTime'  ;
       'Y'  : tmpstr := tmpstr + ' Bytes   '  ;
       'V'  : tmpstr := tmpstr + ' VarBytes'  ;
       'O'  : tmpstr := tmpstr + ' Blob    '  ;
       'M'  : tmpstr := tmpstr + ' Memo    '  ;
       'G'  : tmpstr := tmpstr + ' Graphic '  ;
       end; {Case}
 tmpstr := tmpstr + ' : ';
 if Which.findfield('REQUIRED').asBoolean
   then tmpstr := tmpstr + 'is Required : '
   else tmpstr := tmpstr + 'not required: ';
 if Which.findfield('FIELD_IDX').asBoolean
   then tmpstr := tmpstr + 'is Index : '
   else tmpstr := tmpstr + 'not Index: ';
 result := tmpstr;
 end;

Constructor TDictCTrl.Create(aOwner : tcomponent);
begin
  inherited create(aOwner);
  fdbsg := tstringgrid.create(self);
  FdbTableList := TstringList.create;
  fTempdbMemo := Tdbmemo.create(self);
end;

Destructor TDictCtrl.PutAway;
begin
  Fdbsg.free;
  FdbTableList.free;
  FtempdbMemo.free;
  inherited destroy;
end;


Procedure TDictCtrl.ReadIniFile;
begin
  FIniFile := TiniFile.Create(appname+'.ini');
  FCtrlDictName := FiniFile.ReadString('CtrlDict', 'current', appname+'.dbf');
  FiniFile.free;
end;

function TDictCtrl.getDictPath : tfilename;
begin
  result := extractFilePath(FCtrlDictName);
end;
procedure TDictCtrl.setDictPath( tmpstr : tfilename);
begin
  FCtrlDictName := tmpstr;
end;
function TDictCtrl.getDictTable : tfilename;
begin
  result := extractFileName(FCtrlDictName);
end;
procedure TDictCtrl.setDictTable (tmpstr : tfilename);
begin
end;


Function GetBlobSize(Field: TBlobField): Longint;
begin
  with TBlobStream.Create(Field, bmRead) do
  try
    Result := Seek(0, 2);
  finally
    Free;
  end;
end;

Function GetBlobInfo(Field: TBlobField): String;
var len : longint;
begin
  with TBlobStream.Create(Field, bmRead) do
  try
    len := Seek(0, 2);
  finally
    Free;
  end;
  if len = 0
    then result := ''
    else result := '['+intTostr(len)+']';
end;

{================= Building string grid ===============}


Function Getfirst255char(Field: TBlobField): String;
var  len : longint;
     p : array[0..256] of char;
begin
  with TBlobStream.Create(Field, bmRead) do
  try
    read(p, 255);
    len := Seek(0, 2);
  finally
    Free;
  end;
  if len = 0
    then result := ''
    else result := strpas(p);
end;


function TDictCtrl.GetFieldAsString(const fieldname: string; var whichtable : ttable): string;
var thisField : tfield;
begin
  thisField := whichTable.findfield(fieldname);
  If thisField = nil
    then result := 'nil'
    else
      case  thisField.datatype of
       ftUnknown    : result := 'UNKNOWN';
       ftString     : result := thisfield.text;
       ftSmallint   ,
       ftInteger    ,
       ftWord       ,
       ftBoolean    ,
       ftFloat      ,
       ftCurrency   ,
       ftBCD        ,
       ftDate       ,
       ftTime       ,
       ftDateTime   : result := thisfield.asString;
       ftBytes      ,
       ftVarBytes   ,
       ftBlob       ,
       ftMemo       ,
       ftGraphic    : result := GetFirst255Char(TblobField(thisfield));
      end;
end;


procedure TDictCtrl.OpenDictionary(const fullTableName : string;
                               var whichdb : tdatabase; var whichtable : ttable;
                               var whichQuery : tquery; var whichsource : tDataSource);
begin
  Screen.cursor := crHourglass;
  FCtrlDictName := fullTableName;
  try
    WhichDB.close;
    WhichDB.Params.clear;
    WhichDB.Params.Add('PATH='+ExtractFilePath(FullTableName));
    WhichDB.open;
    WhichTable.DatabaseName:= WhichDB.databasename;
    WhichTable.tablename := ExtractFileName(FullTableName);
    WhichTable.Active:= True;
    WhichSource.DataSet:= WhichTable;
  except
     on EdataBaseError do begin
       MessageDlg('Could not open '+DictPath + ' '+DictTable, mtInformation, [mbOK], 0);
       Screen.cursor := crDefault;
       exit;
       end;
     end; {of exceptions}
  {Now build and fill in DBSG, the data base dictionary string grid}
  FillStringGRid(WhichTable);
  FDBSGGood := true;
{  WhichTable.close;
  WhichDB.close;}
  Screen.cursor := crDefault;
end;

Procedure TDictCtrl.FillStringGrid(var WhichTable : Ttable);
var
  cur_row   : integer;
  dictField : DDFOffsets;
begin
  try
    WhichTable.first;
    cur_row := 0;
    fdbsg.free;
    fdbsg := tstringGrid.create(self);
    fDBSG.rowcount := WhichTable.recordCount;
    fDBSG.colcount := WhichTable.fieldCount;
    while not WhichTable.eof do begin
      for dictField := ddfTable_Name to ddfFormula do
         fDBSG.rows[cur_row].strings[ord(dictField)]
           := GetFieldAsString(DictTableFieldNames[dictField], WhichTable);
        inc(cur_row);
        WhichTable.next;
        end;
      {end;}
  except
    on EdataBaseError do begin
     screen.cursor := crDefault;
     MessageDlg('Problem reading fields in from dictionary', mtInformation, [mbOK], 0);
     exit;
     end;
  end; {of exceptions}
  if whichTable.recordCount <> 0
    then FillTableList;
end;

Procedure TDictCtrl.FillTableList;
var tablefound,
    done : boolean;
    thisTable : string;
    i, j : integer;
begin
  FdbTableList.clear;
  with FDBSG.cols[ord(ddfTable_name)] do begin
    j := 0;
    done := false;
    if count = 0 then exit;
    while not done do begin
      TableFound := false;
      thisTable := strings[j];
      for i := 0 to FdbTableList.count -1 do
        if FdbTableList.strings[i] = thistable
          then begin
            tablefound := true;
            break;
            end;
      if not tablefound
        then FdbTAbleList.add(thisTable);
      inc(j);
      if j = count -1
        then done := true;
      end; {while loop}
    end; {with FDBSG}
end;




function TDictCtrl.SetCurrentFieldTo(const tablename, fieldname : string): boolean;
var i : integer;
begin
  result := false;
  for i := 0 to FDBSG.rowcount -1 do
    if (upper(fDBSG.rows[i].strings[ord(ddfTable_name)]) = upper(tablename))
        and (upper(fDBSG.rows[i].strings[ord(ddffield_name)]) = upper(fieldname))
      then begin
        fCurrentField := i;
        FCurrentFieldName := fieldName;
        FCurrentTableName := TableName;
        result := true;
        break;
        end;
end;

function TDictCtrl.getCurrentTableName : string;
begin
  if (FcurrentField > 0) and (FcurrentField < fDBSG.rowcount)
      then result := fDBSG.rows[fCurrentField].strings[ord(ddfTable_name)]
      else result := '';
end;

function TDictCtrl.getCurrentFieldName : string;
begin
  if (FcurrentField > 0) and (FcurrentField < fDBSG.rowcount)
      then result := fDBSG.rows[fCurrentField].strings[ord(ddfField_name)]
      else result := '';
end;



function TDictCtrl.getCurrentHint: string;
begin
  if (FcurrentField > 0) and (FcurrentField < fDBSG.rowcount)
      then result := fDBSG.rows[fCurrentField].strings[ord(ddfHint)]
      else result := '';  {probably should raise an exception here}
end;

function TDictCtrl.Getrequired : boolean;
begin
  if (FcurrentField > 0) and (FcurrentField < fDBSG.rowcount)
      then if Upper(fDBSG.rows[fCurrentField].strings[ord(ddfRequired)]) = 'TRUE'
          then result := true
          else result := false
      else result := false;
    { else probably should raise an exception here}
end;

function TDictCtrl.GetMinVal : longint;
begin
  if (FcurrentField > 0) and (FcurrentField < fDBSG.rowcount)
      then if fDBSG.rows[fCurrentField].strings[ord(ddfMinVal)] <> ''
          then result := StrToInt(fDBSG.rows[fCurrentField].strings[ord(ddfMinVal)])
          else result := 0
      else result := 0;
    { else probably should raise an exception here}
    {also need to check that we did in fact have a number here}
    {also not sure we want 0 to be the default...}
end;

function TDictCtrl.GetMaxVal : longint;
begin
  if (FcurrentField > 0) and (FcurrentField < fDBSG.rowcount)
      then if fDBSG.rows[fCurrentField].strings[ord(ddfMaxVal)] <> ''
          then result := StrToInt(fDBSG.rows[fCurrentField].strings[ord(ddfMaxVal)])
          else result := 0
      else result := 0;
    { else probably should raise an exception here}
    {also need to check that we did in fact have a number here}
    {also not sure we want 0 to be the default...}
end;



function TDictCtrl.SetUpTable(var TableToSetUp : ttable): boolean;
var fieldnum  : integer;
    WhichTable : string;
    foundit   : boolean;
begin
  result := false;
  WhichTable := TableToSetUp.name;
  with fDBSG do begin
    for fieldnum := 0 to RowCount - 1 do
      if Rows[0].strings[fieldnum] = whichTable
        then
           If SetFieldDefs(TableToSetUp, fieldnum)
             then result := true;
    end;
end;

function TDictCtrl.setFieldDefs(var tableToDefine : Ttable; const fieldnum : integer): boolean;
var
  fldtype : TfieldType;
begin
  result := false;
  result := SetUpCommon(tableToDefine, fieldnum);
  if result = false then exit;
  for fldtype := ftunknown to ftgraphic do
    if FDBSG.cells[ord(ddfField_type), fieldnum] = FieldTypeStr[fldtype]
        then break;
    case fldtype of
       ftString     : Result := SetUpString(tableToDefine, FieldNum);
       ftSmallint  ,
       ftInteger   ,
       ftWord       : Result := DoNumbers(fldtype, tableToDefine, FieldNum);
       ftBoolean    : Result := SeTUpBoolean(tableToDefine, FieldNum);
       ftFloat     ,
       ftCurrency  ,
       ftBCD        : Result := DoNumbers(fldtype, tableToDefine, FieldNum);
       ftDate       : Result := SetUpDate(tableToDefine, FieldNum);
       ftTime       : Result := SetUpTime(tableToDefine, FieldNum);
       ftDateTime   : Result := SetUpDateTime(tableToDefine, FieldNum);
       ftBytes      : Result := SetUpBytes(tableToDefine, FieldNum);
       ftVarBytes   : Result := SetUpVarBytes(tableToDefine, FieldNum);
       ftBlob       : Result := SetUpBlob(tableToDefine, FieldNum);
       ftMemo       : Result := SetUpMemo(tableToDefine, FieldNum);
       ftGraphic    : Result := SetUpGraphic(tableToDefine, FieldNum);
       end; {Case & for}
end;

function TDictCtrl.SetUpCommon(var TableToDefine : ttable; const FieldNum : integer): boolean;
var whichfield : string;
begin with FDBSG do begin
  whichfield := cells[ord(ddfField_name), FieldNum];
  result := false;
  try
    if cells[ord(ddftag), FieldNum] <> ''
      then TableToDefine.findField(whichField).tag := StrToint(cells[ord(ddftag), FieldNum]);
    if cells[ord(ddfgrd_prompt), FieldNum] <> ''
      then TableToDefine.findfield(whichField).DisplayLabel := cells[ord(ddfgrd_prompt), FieldNum];
    if cells[ord(ddfgrd_width), FieldNum] <> ''
      then TableToDefine.findfield(whichField).DisplayWidth := StrToInt(cells[ord(ddfgrd_width), FieldNum]);
    if cells[ord(ddfEditMask), FieldNum] <> ''
      then TableToDefine.findField(whichfield).EditMask
              := cells[ord(ddfEditMask), FieldNum];
    if upper(cells[ord(ddfrequired) ,FieldNum]) = 'TRUE'
      then TableToDefine.findfield(whichfield).required := true
      else TableToDefine.findField(whichField).required := false;
    result := true;
   except
    on E: EConvertError do
     MessageDlg('Error in '+WhichField+': Not a number ' + E.Message, mtInformation, [mbOK], 0);
   else
     MessageDlg('Unknown error in SetUpCommon for '+WhichField, mtInformation, [mbOK],0);
   end;  {try..except}
  end; {with FDBSG}
end;


function TDictCtrl.SetUpString(var TableToDefine : ttable; const FieldNum : integer): boolean;
var whichfield : string;
begin with fDBSG do begin
  whichfield := cells[ord(ddffield_name), FieldNum];
  result := false;
  try
    if cells[ord(ddfscr_Fmt), FieldNum] <> ''
      then TableToDefine.findField(whichfield).EditMask
              := cells[ord(ddfscr_Fmt),FieldNum];
    if cells[ord(ddfEditMask), FieldNum] <> ''
      then TableToDefine.findField(whichfield).EditMask
              := cells[ord(ddfEditMask), FieldNum];
    if cells[ord(ddffield_len), FieldNum] <> ''
      then TableToDefine.findField(whichField).size := StrToint(cells[ord(ddffield_len), FieldNum]);
    result := true;
   except
    on E: EConvertError do
     MessageDlg('Error in '+WhichField+': Not a number ' + E.Message, mtInformation, [mbOK], 0);
   else
     MessageDlg('Unknown error in SetUpCommon for '+WhichField, mtInformation, [mbOK],0);
   end;  {try..except}
  end;
end;

function TDictCtrl.SetUpBoolean(var TableToDefine : ttable; const FieldNum : integer): boolean;
var whichfield : string;
begin with fDBSG do begin
  whichfield := cells[ord(ddffield_name), FieldNum];
  result := false;
  try
    if cells[ord(ddfValList), FieldNum] <> ''
      then TBooleanField(TableToDefine.findField(whichfield)).DisplayValues
            := cells[ord(ddfValList), FieldNum];
    result := true;
   except
     MessageDlg('Unknown error in SetUpCommon for '+WhichField, mtInformation, [mbOK],0);
   end;  {try..except}
  end;
end;


function TDictCtrl.SetUpDate(var TableToDefine : ttable; const FieldNum : integer): boolean;
begin
  result := true;
end;

function TDictCtrl.SetUpDateTime(var TableToDefine : ttable; const FieldNum : integer): boolean;
begin
  result := true;
end;

function TDictCtrl.SetUpTime(var TableToDefine : ttable; const FieldNum : integer): boolean;
begin
  result := true;
end;

function TDictCtrl.SetUpBytes(var TableToDefine : ttable; const FieldNum : integer): boolean;
var whichfield : string;
begin with fDBSG do begin
  whichfield := cells[ord(ddffield_name), FieldNum];
  result := false;
  try
    if cells[ord(ddfField_len), FieldNum] <> ''
      then TBytesField(TableToDefine.findField(whichfield)).Size
            := strToInt(cells[ord(ddfField_len), FieldNum]);
    result := true;
   except
    on E: EConvertError do
     MessageDlg('Field Size Error in '+WhichField+': Not a number ' + E.Message, mtInformation, [mbOK], 0);
   else
     MessageDlg('Unknown error in SetUpBytes for '+WhichField, mtInformation, [mbOK],0);
   end;  {try..except}
  end;
end;

function TDictCtrl.SetUpVarBytes(var TableToDefine : ttable; const FieldNum : integer): boolean;
var whichfield : string;
begin with fDBSG do begin
  whichfield := cells[ord(ddffield_name), FieldNum];
  result := false;
  try
    if cells[ord(ddfField_len), FieldNum] <> ''
      then TVarBytesField(TableToDefine.findField(whichfield)).Size
            := strToInt(cells[ord(ddfField_len), FieldNum]);
    {not checking to insure value is 0..64K}
    result := true;
   except
    on E: EConvertError do
     MessageDlg('Field Size Error in '+WhichField+': Not a number ' + E.Message, mtInformation, [mbOK], 0);
   else
     MessageDlg('Unknown error in SetUpVarBytes for '+WhichField, mtInformation, [mbOK],0);
   end;  {try..except}
  end;
end;

function TDictCtrl.SetUpBlob(var TableToDefine : ttable; const FieldNum : integer): boolean;
var whichfield : string;
begin with fDBSG do begin
  whichfield := cells[ord(ddffield_name), FieldNum];
  result := false;
  try
    if cells[ord(ddfField_len), FieldNum] <> ''
      then TBlobField(TableToDefine.findField(whichfield)).Size
            := strToInt(cells[ord(ddfField_len), FieldNum]);
    result := true;
   except
    on E: EConvertError do
     MessageDlg('Field Size Error in '+WhichField+': Not a number ' + E.Message, mtInformation, [mbOK], 0);
   else
     MessageDlg('Unknown error in SetUpBlob for '+WhichField, mtInformation, [mbOK],0);
   end;  {try..except}
  end;
end;

function TDictCtrl.SetUpMemo(var TableToDefine : ttable; const FieldNum : integer): boolean;
var whichfield : string;
begin with fDBSG do begin
  whichfield := cells[ord(ddffield_name), FieldNum];
  result := false;
  try
    if cells[ord(ddfField_len), FieldNum] <> ''
      then TMemoField(TableToDefine.findField(whichfield)).Size
            := strToInt(cells[ord(ddfField_len), FieldNum]);
    result := true;
   except
    on E: EConvertError do
     MessageDlg('Field Size Error in '+WhichField+': Not a number ' + E.Message, mtInformation, [mbOK], 0);
   else
     MessageDlg('Unknown error in SetUpMemo for '+WhichField, mtInformation, [mbOK],0);
   end;  {try..except}
  end;
end;

function TDictCtrl.SetUpGraphic(var TableToDefine : ttable; const FieldNum : integer): boolean;
var whichfield : string;
begin with fDBSG do begin
  whichfield := cells[ord(ddffield_name), FieldNum];
  result := false;
  try
    if cells[ord(ddfField_len), FieldNum] <> ''
      then TGraphicField(TableToDefine.findField(whichfield)).Size
            := strToInt(cells[ord(ddfField_len), FieldNum]);
    result := true;
   except
    on E: EConvertError do
     MessageDlg('Field Size Error in '+WhichField+': Not a number ' + E.Message, mtInformation, [mbOK], 0);
   else
     MessageDlg('Unknown error in SetUpGraphic for '+WhichField, mtInformation, [mbOK],0);
   end;  {try..except}
  end;
end;

function TDictCtrl.doNumbers(const whichtype : TfieldType; var TableToDefine : ttable; const FieldNum : integer): boolean;
var whichfield : string;
begin with fDBSG do begin
  whichfield := cells[ord(ddffield_name), FieldNum];
  result := false;
  try
      case whichtype of
        ftSmallInt: begin
                      if cells[ord(ddfMinVal), FieldNum] <> ''
                        then TSmallIntField(TableToDefine.findField(whichField)).minvalue
                                := StrToInt(cells[ord(ddfMinVal), FieldNum]);
                      if cells[ord(ddfMaxVal), FieldNum] <> ''
                        then TSmallIntField(TableToDefine.findField(whichField)).maxvalue
                                := StrToInt(cells[ord(ddfMaxVal), FieldNum]);
                      end;
        ftInteger: begin
                     if cells[ord(ddfMinVal), FieldNum] <> ''
                       then TIntegerField(TableToDefine.findField(whichField)).minvalue
                               := StrToInt(cells[ord(ddfMinVal), FieldNum]);
                     if cells[ord(ddfMaxVal), FieldNum] <> ''
                       then TIntegerField(TableToDefine.findField(whichField)).maxvalue
                               := StrToInt(cells[ord(ddfMaxVal), FieldNum]);
                     end;

        ftword : begin
                  if cells[ord(ddfMinVal), FieldNum] <> ''
                    then TWordField(TableToDefine.findField(whichField)).minvalue
                            := StrToInt(cells[ord(ddfMinVal), FieldNum]);
                  if cells[ord(ddfMaxVal), FieldNum] <> ''
                    then TWordField(TableToDefine.findField(whichField)).maxvalue
                            := StrToInt(cells[ord(ddfMaxVal), FieldNum]);
                  end;
        ftFloat: begin
                  if cells[ord(ddfMinVal), FieldNum] <> ''
                    then TFloatField(TableToDefine.findField(whichField)).minvalue
                            := StrToInt(cells[ord(ddfMinVal), FieldNum]);
                  if cells[ord(ddfMaxVal), FieldNum] <> ''
                    then TFloatField(TableToDefine.findField(whichField)).maxvalue
                            := StrToInt(cells[ord(ddfMaxVal), FieldNum]);
                  if cells[ord(ddfField_len), FieldNum] <> ''
                   then TFloatField(TableToDefine.findField(whichfield)).Precision
                           := StrToInt(cells[ord(ddfField_len), FieldNum]);
                             end;
        ftCurrency : begin {ftCurrency}
                      if cells[ord(ddfMinVal), FieldNum] <> ''
                        then TCurrencyField(TableToDefine.findField(whichField)).minvalue
                                := StrToInt(cells[ord(ddfMinVal), FieldNum]);
                      if cells[ord(ddfMaxVal), FieldNum] <> ''
                        then TCurrencyField(TableToDefine.findField(whichField)).maxvalue
                                := StrToInt(cells[ord(ddfMaxVal), FieldNum]);
                      if cells[ord(ddfField_len), FieldNum] <> ''
                       then TCurrencyField(TableToDefine.findField(whichfield)).Precision
                               := StrToInt(cells[ord(ddfField_len), FieldNum]);
                     end;
         ftBCD: begin
                  if cells[ord(ddfMinVal), FieldNum] <> ''
                    then TBCDField(TableToDefine.findField(whichField)).minvalue
                            := StrToInt(cells[ord(ddfMinVal), FieldNum]);
                  if cells[ord(ddfMaxVal), FieldNum] <> ''
                    then TBCDField(TableToDefine.findField(whichField)).maxvalue
                            := StrToInt(cells[ord(ddfMaxVal), FieldNum]);
                  if cells[ord(ddfField_len), FieldNum] <> ''
                   then TBCDField(TableToDefine.findField(whichfield)).Precision
                           := StrToInt(cells[ord(ddfField_len), FieldNum]);
                 end;
           end; {Case }
   except
    on E: EConvertError do
     MessageDlg('Error in '+WhichField+': Not a number ' + E.Message, mtInformation, [mbOK], 0);
   else
     MessageDlg('Unknown error in SetUpCommon for '+WhichField, mtInformation, [mbOK],0);
   end;  {try..except}
  end;   {with DBSG}
end;


{=================================== build table ===============================}

function TDictCtrl.BuildEmptyTable(var TableToBuild : ttable; const TableName : string): boolean;
  {TableToBuild is assumed to be an empty, newly created table for which
   databasename, tabletype, and tablename (same as given) have been set}
var fieldnum : integer;
    fldtype : TFieldType;
    fieldname : string;
    fieldlen  : integer;
    IsIndex,
    IsRequired   : boolean;
begin
  result := false;
  TableToBuild.FieldDefs.clear;
  TableToBuild.IndexDefs.clear;
  with fDBSG do begin
    for fieldnum := 0 to RowCount - 1 do
      if cells[ord(ddfTable_name), fieldnum] = TableName
        then begin
          for fldtype := ftunknown to ftgraphic do
            if cells[ord(ddfField_type), fieldnum] = FieldTypeStr[fldtype]
                then break;
          fieldname := cells[ord(ddfField_name), fieldnum];
          if upper(cells[ord(ddfrequired) ,FieldNum]) = 'TRUE'
            then IsRequired := true
            else IsRequired := false;
          if upper(cells[ord(ddfField_idx) ,FieldNum]) = 'TRUE'
            then IsIndex := true
            else IsIndex := false;
          case fldtype of
             ftString     : fieldlen := StrToInt(cells[ord(ddfField_len),fieldnum]);
             ftSmallint  ,
             ftInteger   ,
             ftWord      ,
             ftBoolean   ,
             ftFloat     ,
             ftCurrency  ,
             ftBCD       ,
             ftDate      ,
             ftTime      ,
             ftDateTime  : fieldlen := 0;
             ftBytes     ,
             ftVarBytes  ,
             ftBlob      ,
             ftMemo      ,
             ftGraphic   : fieldLen := StrToInt(cells[ord(ddfField_len), fieldnum]);
             end; {Case}
           with TableToBuild.FieldDefs do begin
             try
               add(fieldname, fldtype, fieldlen, IsRequired);
               if IsIndex
                 then TableToBuild.IndexDefs.add(fieldname, fieldname, [ixPrimary, ixUnique]);
               except
                 on E: EDBEngineError do begin
                   messagedlg('Error with '+fieldname+': '+E.message, mtInformation, [mbOk],0);
                   result := false;
                   end; {on error}
               end; {try..except}
             end; {with FieldDefs}
          end; {of is a field in this table}
    end; {of with FDBSG}
    try
      TableToBuild.CreateTable;
      result := true;
     except
       on E: EDBEngineError do begin
         messagedlg('BDE error creating table '+ tablename + ': '+E.message, mtInformation, [mbOK],0);
         messagedlg('there are '+ IntTostr(E.ErrorCount)+' errors.', mtInformation, [mbOK],0);
         for fieldlen := 0 to E.errorCount -1 do
           messagedlg('#'+IntToStr(fieldlen)+': '+ E.Errors[fieldlen].message, mtInformation, [mbOK],0);
         result := false;
         end;
       end;
end;




{=====================================  misc ===================================}




function openDB(var whichdb : tdatabase; var whichtable : ttable;
                var whichQuery : tquery; var whichsource : tDataSource;
                const pathname, tablename : string): boolean;
begin
  try
    WhichDB.close;
    WhichDB.Params.clear;
    WhichDB.Params.Add('PATH='+PathName);
    WhichDB.open;
    WhichTable.DatabaseName:= WhichDB.databasename;
    WhichTable.tablename := TableName;
    WhichTable.Active:= True;
    WhichSource.DataSet:= WhichTable;
    WhichQuery.databaseName := WhichDB.databasename;
    WhichQuery.dataSource := WhichSource;
    WhichQuery.close;
    WhichQuery.sql.clear;
    WhichQuery.params.clear;
    result := true;
  except
     on EdataBaseError do begin
       screen.cursor := crDefault;
       MessageDlg('Could not open '+pathname + ' '+tablename, mtInformation, [mbOK], 0);
       result := false;
       end;
     end; {of exceptions}
end;

   {
           TIntegerField       Whole numbers in the range -2,147,483,648 to 2,147,483,647
            TWordField  Whole numbers in the range 0 to 65535
            TBooleanField       True or False values
            TFloatField Real numbers with absolute magnitudes from 5.0*10-324 to 1.7*10308
                            accurate to 15-16 digits
            TCurrencyField      Currency values. The range and accuracy is the same as TFloatField
            TBCDField   Real numbers with a fixed number of digits after the decimal point.
                            Accurate to 18 digits. Range depends on the number of digits after the
                             decimal point. [Paradox only]
            TDateField  Date value
            TTimeField  Time value
            TDateTimeField      Date and time value
            TBytesField Arbitrary data field without a size limit
            TVarBytesField      Arbitrary data field up to 65535 characters, with the actual length stored
                            in the first two bytes
            TBlobField  Arbitrary data field without a size limit
            TMemoField  Arbitrary length text
            TGraphicField       Arbitrary length graphic, such as a bitmap
             }

procedure Register;
begin
  RegisterComponents('Synature', [tdictctrl]);
end;


Initialization

dictCtrl := tdictCtrl.create(application);

DBSGExists := false;

end.


{
    pbuffer : pointer;
    pRecBufr : pointer;
    dbicallrslt : DBIResult;
    BLOBlen,
    BLOBread : longint;

         begin
           getmem(pbuffer, sizeof(buffer));
           getmem(pRecBufr, sizeof(buffer));
           dbiCallRslt := DbiOpenBlob(whichTable.handle, pRecBufr, thisField.fieldno,dbireadonly);
           if dbiCallRslt = DBIERR_NONE
              then begin
                dbicallRslt := DbiGetBlobSize(whichTable.handle,pRecBufr,thisField.fieldno,BLOBlen);
                dbiCallRslt := DbiGetBlob(whichTable.handle,pRecBufr, thisField.fieldno, 0, sizeof(buffer), pbuffer, BLOBread);
                if (dbiCallRslt = DBIERR_NONE) or (dbiCallRslt = DBIERR_ENDOFBLOB)
                 then begin
                    dbicallRslt := DbiGetBlobSize(whichTable.handle,pRecBufr,thisField.fieldno,BLOBlen);
                    if dbicallRslt = DBIERR_NONE
                      then result := 'z'+intTostr(BLOBlen)
                      else result := 'zz';
                    end
                   else case
                    dbiCallRslt of
                      DBIERR_INVALIDBLOBHANDLE : result := 'y handle';
                      DBIERR_INVALIDPARAM : result := 'y param';
                      DBIERR_NOTABLOB : result := 'y not blob';
                      DBIERR_INVALIDBLOBOFFSET : result := 'y offset';
                      DBIERR_TABLEREADONLY : result := 'y read';
                      end;
                end
              else case dbiCallrslt of
                      DBIERR_INVALIDHNDL : result := 'x handle';
                      DBIERR_INVALIDPARAM : result := 'x param';
                      DBIERR_OUTOFRANGE : result := 'x range';
                      DBIERR_BLOBOPENED : result := 'x open';
                      DBIERR_NOTABLOB : result := 'x not blob';
                      DBIERR_OPENBLOBLIMIT : result := 'x limit';
                      DBIERR_TABLEREADONLY : result := 'x read';
                      end;
           dbiCallRslt := DbiFreeBlob(whichTable.handle, pRecBufr, thisField.fieldno);

           freemem(pbuffer, sizeof(buffer));
           freemem(pRecBufr, sizeof(buffer));
           end;}